Supercompiler 1997/SUPERCOMPILER97.iso/Delphi 3.0/DATA.Z/report.pas

Pascal/Delphi Source File | 1997-01-29 | 32.3 KB | 1,189 lines

{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1995,97 Borland International     }
{                                                       }
{*******************************************************}

unit Report;

{$Z+,R-}

interface

uses SysUtils, Windows, Classes, Controls, Forms, DDEMan, DB, Messages;

const
  ctDBase = 2;
  ctExcel = 3;
  ctParadox = 4;
  ctAscii = 5;
  ctSqlServer = 6;
  ctOracle = 7;
  ctDB2 = 8;
  ctNetSQL = 9;
  ctSybase = 10;
  ctBtrieve = 11;
  ctGupta = 12;
  ctIngres = 13;
  ctWatcom = 14;
  ctOcelot = 15;
  ctTeraData = 16;
  ctDB2Gupta = 17;
  ctAS400 = 18;
  ctUnify = 19;
  ctQry = 20;
  ctMinNative = 2;
  ctMaxNative = 20;
  ctODBCDBase = 40;
  ctODBCExcel = 41;
  ctODBCParadox = 42;
  ctODBCSqlServer = 43;
  ctODBCOracle = 44;
  ctODBCDB2 = 45;
  ctODBCNetSql = 46;
  ctODBCSybase = 47;
  ctODBCBtrieve = 48;
  ctODBCGupta = 49;
  ctODBCIngres = 50;
  ctODBCDB2Gupta = 51;
  ctODBCTeraData = 52;
  ctODBCAS400 = 53;
  ctODBCDWatcom = 54;
  ctODBCDefault = 55;
  ctODBCUnify = 56;
  ctMinODBC = 40;
  ctMaxODBC = 56;
  ctIDAPIStandard = 60;
  ctIDAPIParadox = 61;
  ctIDAPIDBase = 62;
  ctIDAPIAscii = 63;
  ctIDAPIOracle = 64;
  ctIDAPISybase = 65;
  ctIDAPINovSql = 66;
  ctIDAPIInterbase = 67;
  ctIDAPIIBMEE = 68;
  ctIDAPIDB2 = 69;
  ctIDAPIInformix = 70;
  ctMinIDAPI = 60;
  ctMaxIDAPI = 70;

type
  EReportError = class(Exception);
  TReportManager = class;
  TLaunchType = (ltDefault, ltRunTime, ltDesignTime);

  TReport = class(TComponent)
  private
    FOwner: TReportManager;
    FReportName: string;
    FReportDir: string;
    FNumCopies: Word;
    FStartPage: Word;
    FEndPage: Word;
    FMaxRecords: Word;
    FRunTime: Boolean;
    FStartedApp: Boolean;
    FAutoUnload: Boolean;
    FInitialValues: TStrings;
    FVersionMajor: Integer;
    FVersionMinor: Integer;
    FReportHandle: HWND;
    FPreview: Boolean;
    FLaunchType: TLaunchType;
    function GetBusy: Boolean;
    function GetInitialValues: TStrings;
    function GetReportHandle: HWND;
    procedure RunApp;
    procedure StartApplication;
    function ReportActive: Boolean;
    function RunReport: Integer;
    procedure SetInitialValues(Value: TStrings);
    function UseRunTime: Boolean;
  protected
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function CloseApplication(ShowDialogs: Boolean): Integer;
    function CloseReport(ShowDialogs: Boolean): Integer;
    function Connect(ServerType: Word; const ServerName,
      UserName, Password, DatabaseName: string): Integer;
    function Print: Integer;
    function RecalcReport: Integer;
    function Run: Integer;
    function RunMacro(const Macro: string): Integer;
    function SetVariable(const Name, Value: string): Integer;
    function SetVariableLines(const Name: string; Value: TStrings): Integer;
    property ReportHandle: HWND read FReportHandle;
    property Busy: Boolean read GetBusy;
    property VersionMajor: Integer read FVersionMajor;
    property VersionMinor: Integer read FVersionMinor;
  published
    property ReportName: string read FReportName write FReportName;
    property ReportDir: string read FReportDir write FReportDir;
    property PrintCopies: Word read FNumCopies write FNumCopies default 1;
    property StartPage: Word read FStartPage write FStartPage default 1;
    property EndPage: Word read FEndPage write FEndPage default 9999;
    property MaxRecords: Word read FMaxRecords write FMaxRecords default 0;
    property AutoUnload: Boolean read FAutoUnload write FAutoUnload default False;
    property InitialValues: TStrings read GetInitialValues write SetInitialValues;
    property Preview: Boolean read FPreview write FPreview default False;
    property LaunchType: TLaunchType read FLaunchType write FLaunchType default ltDefault;
  end;

{ TReportManager }

  TCallType = (ctNone, ctDesignId, ctExecuteSQL, ctEndSQL,
    ctGetError, ctGetTableList, ctGetColumnList, ctGetNext, ctGetMemo);

  PCallInfo = ^TCallInfo;
  TCallInfo = record
    ProcessId: THandle;
    CallType: TCallType;
    ErrorCode: Bool;
    Data: record end;
  end;

  PRSDateTime= ^TRSDateTime;
  TRSDateTime = record
    Year: Word;
    Month: Word;
    Day: Word;
    Hour: Word;
    Min: Word;
    Sec: Word;
    MSec: Word;
  end;

  PDataElement = ^TDataElement;
  TDataElement = packed record
    FieldType: Integer;
    ColumnName: array[0..31] of char;
    FieldLength: Word;
    Null: Bool;
    Data: record end;
  end;

  PExecInfo = ^TExecInfo;
  TExecInfo = record
    DataSet: TDataSet;
    MoreRecords: Bool;
    NumCols: Word;
  end;

  PStartExecInfo = ^TStartExecInfo;
  TStartExecInfo = record
    StmtIndex: Integer;
    StmtName: array[0..19] of char;
    MemoName: array[0..19] of char;
    TableName: array[0..63] of char;
  end;

  PMemoStruct = ^TMemoStruct;
  TMemoStruct = record
    DataSet: TDataSet;
    Index: Integer;
    ColumnName: array[0..31] of char;
    Pos: Integer;
  end;

  PSQLStruct = ^TSQLStruct;
  TSQLStruct = record
    DataSet: TDataSet;
    Index: Integer;
  end;

  TReportManager = class(TComponent)
  private
    FReports: TList;
    FDataSets: TList;
    FHandle: HWND;
    FLastError: string;
    FUpdated: Boolean;
    procedure ServerProc(Value: PCallInfo);
    procedure WndProc(var Message: TMessage);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Add(Value: TReport);
    procedure AddDataSet(Root: TComponent);
    procedure Clear;
    function EndSQL(SQLStruct: PSQLStruct): Bool;
    function ExecuteSQL(ExecInfo: PExecInfo;
      StartExecInfo: PStartExecInfo): Bool;
    function GetColumnList(Buffer: PChar): Bool;
    function GetData(DataSet: TDataSet; pStmtMem: PDataElement): Bool;
    function GetDataSet(Index: Integer): TDataSet;
    function GetDataSetByName(Value: string): TDataSet;
    function GetDataSets: TList;
    function GetMemo(MemoStruct: PMemoStruct): Bool;
    function GetNext(SQLStruct: PSQLStruct; var MoreData: Bool): Bool;
    function GetReport(Index: Integer): TReport;
    procedure GetTableList(Buffer: PChar);
    procedure Remove(Value: TReport);
    procedure UpdateDataSets;
    function ValidDataType(Value: TFieldType): Boolean;
    property DataSets: TList read GetDataSets;
    property Reports: TList read FReports;
    property DataSet[Index: Integer]: TDataSet read GetDataSet;
    property Handle: HWND read FHandle;
    property Report[Index: Integer]: TReport read GetReport;
{$WARNINGS OFF}
    property Updated: Boolean read FUpdated;
{$WARNINGS ON}
  end;

implementation

uses DBConsts, IniFiles, Registry;

const
  RSAPI = 'rs_api.dll';
  RS_SUCCESS = 0;
  RS_BUSY = 1;
  DesignName = 'ReportSmith';
  RunName = 'RS_RUNTIME';
  ReportClassName: string = 'OwlWindow';
  DesignExeName = 'RptSmith.EXE';
  RunExeName = 'RS_Run.EXE';
  StatementBuffer = $FFFF;
  MemoBuffer = $8000;
  SRegBaseKey = '\software\borland\ReportSmith\3.00';

type
  TServerProc = function(var Data: Integer): Bool stdcall;
  TStmtStruct = record
    StmtHandle: THandle;
    StmtMem: Pointer;
    MemoHandle: THandle;
    MemoMem: Pointer;
  end;

var
  StartEvent: THandle;
  SyncEvent: THandle;
  SharedMem: Pointer;
  ProcessId: Integer;
  ReportManager: TReportManager;
  StmtHandles: array[0..9] of TStmtStruct;
  DriverHandle: THandle;
  APIDriverHandle: THandle;
  InitObjects: function(var StartEvent: THandle; var SyncEvent: THandle;
    var SharedMem: Pointer; ThreadFunc: TThreadStartRoutine):Bool stdcall;
  GetThread: function: THandle stdcall;
  RS_PrintReport: function(StartingPage, EndingPage: Integer; Device, Port, Driver: PChar;
    Copies: Integer): Integer; stdcall;
  RS_SetRepVar: function(Name, Value: PChar): Integer; stdcall;
  RS_Recalc: function: Integer; stdcall;
  RS_CloseReport: function(Close: Integer): Integer; stdcall;
  RS_CloseRS: function(Close: Integer): Integer; stdcall;
  RS_SetRecordLimit: function(Limit: Integer): Integer; stdcall;
  RS_LoadReport: function(FileName, Arguments: PChar; DraftMode,
    RunReport: Bool): Integer; stdcall;
  RS_ByteVersion: function(var Major, Minor: Integer): Word; stdcall;
  RS_Connect: function(ServerType: Integer; const Server, UserId, Password,
    Database: PChar): Integer; stdcall;
  RS_IsBusy: function: Bool; stdcall;
  RS_RunMacro: function(Macro: PChar): Integer; stdcall;
  RS_IsReportSmithPresent: function: Bool; stdcall;
  RS_Initiate: function(RunTime: Bool): Integer; stdcall;
  RS_RegisterCallBack: function(Value: Pointer): Integer; stdcall;

function AsyncCallback: Boolean;
var
  Msg: TMsg;
begin
  if PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then
  begin
    with Application do
    begin
      HandleMessage;
      Result := Terminated;
     end;
  end else
    Result := False
end;

function GetRootDir(RunTime: Boolean): string;
var
  Value: string;
begin
  if RunTime then
    Value := SRptRunTimeValue else
    Value := SRptDesignTimeValue;
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(SRegBaseKey, True);
    Result := ReadString(Value);
  finally
    Free;
  end;
end;

function APIDriverLoaded: Boolean;
begin
  Result := APIDriverHandle >= HINSTANCE_ERROR;
end;

function InitAPIDriver: Boolean;
var
  OldError: Word;
  Path: string;
begin
  OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  try
    Path := GetRootDir(False);
    if Path = '' then
      Path := GetRootDir(True);
    if (Path <> '') and (Path[Length(Path)] <> '\') then
      Path := Path + '\';
    Path := Path + RSAPI;
    APIDriverHandle := LoadLibrary(PChar(Path));
    if APIDriverLoaded then
    begin
      @RS_PrintReport := GetProcAddress(APIDriverHandle, 'RS_PrintReport');
      @RS_SetRepVar := GetProcAddress(APIDriverHandle, 'RS_SetRepVar');
      @RS_Recalc := GetProcAddress(APIDriverHandle, 'RS_Recalc');
      @RS_CloseReport := GetProcAddress(APIDriverHandle, 'RS_CloseReport');
      @RS_CloseRS := GetProcAddress(APIDriverHandle, 'RS_CloseRS');
      @RS_SetRecordLimit := GetProcAddress(APIDriverHandle, 'RS_SetRecordLimit');
      @RS_LoadReport := GetProcAddress(APIDriverHandle, 'RS_LoadReport');
      @RS_ByteVersion := GetProcAddress(APIDriverHandle, 'RS_ByteVersion');
      @RS_Connect := GetProcAddress(APIDriverHandle, 'RS_Connect');
      @RS_IsBusy := GetProcAddress(APIDriverHandle, 'RS_IsAPIBusy');
      @RS_RunMacro := GetProcAddress(APIDriverHandle, 'RS_RunMacroCode');
      @RS_IsReportSmithPresent := GetProcAddress(APIDriverHandle, 'RS_IsReportSmithPresent');
      @RS_Initiate := GetProcAddress(APIDriverHandle, 'RS_InitiateAPI');
      @RS_RegisterCallBack := GetProcAddress(APIDriverHandle, 'RS_RegisterWaitLoopCallback');
    end
    else APIDriverHandle := 1;
  finally
    SetErrorMode(OldError);
  end;
  Result := APIDriverLoaded;
end;

function DriverLoaded: Boolean;
begin
  Result := DriverHandle >= HINSTANCE_ERROR;
end;

function InitDriver: Boolean;
const
  RSDriverName = 'RS_DELPH.DLL';
var
  OldError: Word;
  Path: string;
begin
  OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  try
    Path := GetRootDir(False);
    if Path = '' then
      Path := GetRootDir(True);
    if (Path <> '') and (Path[Length(Path)] <> '\') then
      Path := Path + '\';
    Path := Path + RSDriverName;
    DriverHandle := LoadLibrary(PChar(Path));
    if DriverLoaded then
    begin
      @InitObjects := GetProcAddress(DriverHandle, 'InitObjects');
      @GetThread := GetProcAddress(DriverHandle, 'GetThread');
    end
    else DriverHandle := 1;
  finally
    SetErrorMode(OldError);
  end;
  Result := DriverLoaded;
end;

procedure RaiseError(const Message: string);
begin
  raise EReportError.Create(Message);
end;

procedure GetDecodedDateTime(DateTime: TDateTime; var Value: TRSDateTime);
begin
  with Value do
  begin
    DecodeDate(DateTime, Year, Month, Day);
    DecodeTime(DateTime, Hour, Min, Sec, MSec);
  end;
end;

procedure CleanUpStmt(Value: TStmtStruct);
begin
  with Value do
  begin
    if StmtHandle <> 0 then
    begin
      if StmtMem <> nil then UnmapViewOfFile(StmtMem);
      StmtMem := nil;
      CloseHandle(StmtHandle);
      StmtHandle := 0;
    end;
    if MemoHandle <> 0 then
    begin
      if MemoMem <> nil then UnmapViewOfFile(MemoMem);
      MemoMem := nil;
      CloseHandle(MemoHandle);
      MemoHandle := 0;
    end;
  end;
end;

{ TReport }

constructor TReport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ReportManager.Add(Self);
  PrintCopies := 1;
  StartPage := 1;
  EndPage := 9999;
  MaxRecords := 0;
  FInitialValues := TStringList.Create;
  LaunchType := ltDefault;
end;

destructor TReport.Destroy;
begin
  ReportManager.Remove(Self);
  if FRunTime and FStartedApp then CloseApplication(True);
  FInitialValues.Free;
  inherited Destroy;
end;

procedure TReport.SetInitialValues(Value: TStrings);
begin
  FInitialValues.Assign(Value);
end;

function TReport.GetInitialValues: TStrings;
begin
  Result := FInitialValues;
end;

function TReport.SetVariable(const Name, Value: string): Integer;
begin
  if not Busy then
  begin
    Result := RS_SetRepVar(PChar(Name), PChar(Value));
  end else
    Result := RS_BUSY;
end;

function TReport.SetVariableLines(const Name: string; Value: TStrings): Integer;
var
  Buffer, StrEnd: PChar;
  BufLen: Word;
  I, L, Count: Integer;
  Temp: array[0..255] of Char;
  S: string;
begin
  if not Busy then
  begin
    BufLen := 3;
    for I := 0 to Value.Count - 1 do
    begin
      L := Length(Value[I]) + 2;
      if L > 65520 - BufLen then Break;
      Inc(BufLen, L);
    end;
    Buffer := AllocMem(BufLen);
    try
      StrEnd := StrECopy(Buffer, '"');
      Count := Value.Count - 1;
      for I := 0 to Count do
      begin
        StrCopy(Temp, PChar(Value[I]));
        StrEnd := StrECopy(StrEnd, Temp);
        if I <> Count then StrEnd := StrECopy(StrEnd, ' ');
      end;
      Buffer[StrLen(Buffer)] := '"';
      S := Buffer;
      Result := RS_SetRepVar(PChar(S), nil);
    finally
      FreeMem(Buffer, BufLen);
    end;
  end else
    Result := RS_BUSY;
end;

function TReport.RecalcReport: Integer;
begin
  if not Busy then
    Result := RS_Recalc else
    Result := RS_BUSY;
end;

function TReport.ReportActive: Boolean;
begin
  Result := (ReportHandle <> 0) and (@RS_IsReportSmithPresent <> nil) and
    RS_IsReportSmithPresent;
end;

function TReport.UseRunTime: Boolean;
begin
  Result := (LaunchType = ltRunTime) or
    ((LaunchType = ltDefault) and not (csDesigning in ComponentState));
end;

function TReport.Print: Integer;
begin
  if not Busy then
    Result := RS_PrintReport(StartPage, EndPage, nil, nil, nil, PrintCopies) else
    Result := RS_BUSY;
end;

procedure TReport.StartApplication;
var
  ExeName: string;
  ExePath: string;
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
begin
  ExePath := GetRootDir(FRunTime);
  if FRunTime then
    ExeName := RunExeName else
    ExeName := DesignExeName;
  if (ExePath <> '') and (AnsiLastChar(ExePath)^ <> '\') then
    ExePath := ExePath + '\';
  ExeName := ExePath + ExeName;
  FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  with StartupInfo do
  begin
    cb := SizeOf(TStartupInfo);
    dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
    if not FRunTime or Preview then wShowWindow := SW_SHOWNORMAL
    else wShowWindow := SW_SHOWMINNOACTIVE;
  end;
  FStartedApp := CreateProcess(PChar(ExeName), nil, nil, nil, False,
    NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
  if FStartedApp then
  with ProcessInfo do
  begin
    WaitForInputIdle(hProcess, INFINITE);
    CloseHandle(hThread);
    CloseHandle(hProcess);
    FReportHandle := GetReportHandle;
  end else
    raise Exception.Create(Format(SRptLoadFailed, [ExeName]))
end;

function TReport.CloseReport(ShowDialogs: Boolean): Integer;
begin
  if not RS_IsBusy then
  begin
    if ReportActive then
      Result := RS_CloseReport(Ord(ShowDialogs))
    else Result := RS_SUCCESS;
  end else
    Result := RS_BUSY;
end;

function TReport.Connect(ServerType: Word; const ServerName,
  UserName, Password, DatabaseName: string): Integer;
begin
  Result := 0;
  if not Busy then
  begin
    if ((ServerType >= ctMinNative) and (ServerType <= ctMaxNative)) or
      ((ServerType >= ctMinODBC) and (ServerType <= ctMaxODBC)) or
      ((ServerType >= ctMinIDAPI) and (ServerType <= ctMaxIDAPI)) then
      Result := RS_Connect(ServerType, PChar(ServerName), PChar(UserName),
        PChar(Password), PChar(DatabaseName))
    else RaiseError(SInvalidServer);
  end else
    Result := RS_BUSY;
end;

function TReport.CloseApplication(ShowDialogs: Boolean): Integer;
begin
  if not RS_IsBusy then
  begin
    if ReportActive then
    begin
      Result := RS_CloseRS(Ord(ShowDialogs));
      if Result = RS_SUCCESS then
      begin
        FStartedApp := False;
        FReportHandle := 0;
      end;
    end
    else Result := RS_SUCCESS;
  end else
    Result := RS_BUSY;
end;

function TReport.GetReportHandle: HWND;
var
  S: string;
begin
  if FRunTime then S := RunName
  else S := DesignName;
  Result := FindWindow(PChar(ReportClassName), PChar(S));
end;

function TReport.GetBusy: Boolean;
begin
  if not ReportActive then RunApp;
  Result := RS_IsBusy;
end;

function TReport.RunMacro(const Macro: string): Integer;
begin
  if not Busy then
  begin
    if Macro <> '' then
      Result := RS_RunMacro(PChar(Macro)) else
      Result := RS_SUCCESS;
  end else
    Result := RS_BUSY;
end;

procedure TReport.RunApp;
var
  AppName: string;
begin
  if not APIDriverLoaded then
    raise Exception.Create(Format(SUnableToLoadAPIDLL, [RSAPI]));
  if not ReportActive and not RS_IsBusy then
  begin
    FRunTime := UseRunTime;
    FReportHandle := GetReportHandle;
    if ReportHandle = 0 then StartApplication;
    RS_Initiate(FRunTime);
    if FRunTime then AppName := RunName
    else AppName := DesignName;
    if RS_ByteVersion(FVersionMajor, FVersionMinor) <> RS_SUCCESS then
      raise Exception.CreateFmt(SCannotGetVersionInfo, [AppName]);
    if VersionMajor = 0 then
    begin
      if FStartedApp then CloseApplication(False);
      raise Exception.Create(SIncorrectVersion);
    end;
  end;
end;

function TReport.Run: Integer;
begin
  Result := RunReport;
  if FRunTime and FStartedApp and
    AutoUnload and not Preview then CloseApplication(True);
end;

function TReport.RunReport: Integer;
var
  Path, FileName: string;
  Temp: array[0..255] of Char;
  Buffer, StrEnd: PChar;
  BufLen: Word;
  I, L, Count: Integer;
  S: string;
begin
  if not Busy then
  begin
    Result := RS_SetRecordLimit(MaxRecords);
    if Result = RS_SUCCESS then
    begin
      Path := ReportDir;
      if (Path <> EmptyStr) and (AnsiLastChar(Path)^ <> '\') then
        Path := Path + '\';
      FileName := ReportName;
      if (FileName <> '') and (Pos('.', FileName) = 0) then
        FileName := FileName + '.rpt';
      if FileName <> '' then
      begin
        FileName := Path + FileName;
        if not FileExists(FileName) then
          raise Exception.CreateFmt(SNoFile, [FileName]);
        BufLen := 3;
        for I := 0 to FInitialValues.Count - 1 do
        begin
          L := Length(FInitialValues[I]) + 2;
          if L > 65520 - BufLen then Break;
          Inc(BufLen, L);
        end;
        Buffer := AllocMem(BufLen);
        try
          StrEnd := StrECopy(Buffer, '"');
          Count := FInitialValues.Count - 1;
          for I := 0 to Count do
          begin
            StrCopy(Temp, PChar(FInitialValues[I]));
            StrEnd := StrECopy(StrEnd, Temp);
            if (I <> Count) and (Pos('>', FInitialValues[I]) > 0) then
              StrEnd := StrECopy(StrEnd, ', ');
          end;
          Buffer[StrLen(Buffer)] := '"';
          S := Buffer;
          FmtStr(S, '%s,"#%x"', [S, ProcessId]);
          Result := RS_LoadReport(PChar(FileName), PChar(S), False, True);
        finally
          FreeMem(Buffer, BufLen);
        end;
        if (Result = RS_SUCCESS) and FRunTime and not Preview then
          Result := Print;
      end;
    end;
  end else
    Result := RS_BUSY;
end;

procedure TReport.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if AComponent is TDataSet then ReportManager.FUpdated := False;
end;

{ TReportManager }

constructor TReportManager.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FReports := TList.Create;
  FDataSets := TList.Create;
  FHandle := AllocateHWnd(WndProc);
end;

destructor TReportManager.Destroy;
begin
  Clear;
  Reports.Free;
  FDataSets.Free;
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;

procedure TReportManager.Clear;
begin
  while Reports.Count > 0 do TReport(Reports.Last).Free;
end;

procedure TReportManager.WndProc(var Message: TMessage);
begin
  if Message.Msg = $7F00 then
  begin
    ServerProc(PCallInfo(SharedMem));
  end
  else with Message do
    Result := DefWindowProc(FHandle, Msg, WParam, LParam);
end;

procedure TReportManager.ServerProc(Value: PCallInfo);
var
  pData: Pointer;
begin
  pData := @Value^.Data;
  with Value^ do
  begin
    ErrorCode := False;
    case CallType of
      ctExecuteSQL: ErrorCode := not ExecuteSQL(PExecInfo(pData),
        PStartExecInfo(pData));
      ctEndSQL: ErrorCode := not EndSQL(PSQLStruct(pData));
      ctGetTableList: GetTableList(PChar(pData));
      ctGetColumnList: ErrorCode := not GetColumnList(PChar(pData));
      ctGetNext: ErrorCode := not GetNext(PSQLStruct(pData), Bool(pData^));
      ctGetMemo: ErrorCode := not GetMemo(PMemoStruct(pData));
      ctGetError: StrCopy(PChar(pData), PChar(FLastError));
    end;
  end;
end;

procedure TReportManager.Add(Value: TReport);
begin
  Reports.Add(Value);
  Value.FOwner := Self;
  FUpdated := False;
end;

procedure TReportManager.Remove(Value: TReport);
begin
  with Reports do Delete(IndexOf(Value));
  Value.FOwner := nil;
  FUpdated := False;
end;

procedure TReportManager.AddDataSet(Root: TComponent);
var
  I: Integer;
begin
  if Root is TDataSet then FDataSets.Add(Root);
  for I := 0 to Root.ComponentCount - 1 do
    AddDataSet(Root.Components[I]);
end;

function TReportManager.GetDataSet(Index: Integer): TDataSet;
begin
  Result := DataSets[Index];
end;

function TReportManager.GetReport(Index: Integer): TReport;
begin
  Result := FReports[Index];
end;

procedure TReportManager.UpdateDataSets;
var
  I, J: Integer;
  Matched: Boolean;
begin
  FDataSets.Clear;
  for I := 0 to Reports.Count - 1 do
  begin
    Matched := False;
    for J := I + 1 to Reports.Count - 1 do
      if Report[I].Owner = Report[J].Owner then
      begin
        Matched := True;
        Break;
      end;
    if not Matched then AddDataSet(Report[I].Owner);
  end;
  FUpdated := True;
end;

function TReportManager.ExecuteSQL(ExecInfo: PExecInfo;
  StartExecInfo: PStartExecInfo): Bool;
var
  I, Size: Integer;
  S: string;
  DataElement: PDataElement;
  pStmtMem, pMemoMem: Pointer;

  function GetDataSize(Value: TField): Integer;
  begin
    case Value.DataType of
      ftString: Result := Value.Size + 1;
      ftSmallint, ftInteger, ftWord, ftBoolean, ftAutoInc:
        Result := SizeOf(Integer);
      ftFloat, ftCurrency, ftBCD:
        Result := SizeOf(Double);
      ftDate, ftTime, ftDateTime:
        Result := SizeOf(TRSDateTime);
      else Result := 0;
    end;
  end;

begin
  Result := False;
  S := StartExecInfo^.TableName;
  with StmtHandles[StartExecInfo^.StmtIndex] do
  begin
    StmtHandle := OpenFileMapping(FILE_MAP_WRITE, False, StartExecInfo^.StmtName);
    if StmtHandle <> 0 then
      pStmtMem := MapViewOfFile(StmtHandle, FILE_MAP_WRITE, 0, 0, 0) else
      pStmtMem := nil;
    StmtMem := pStmtMem;
    MemoHandle := OpenFileMapping(FILE_MAP_WRITE, False, StartExecInfo^.MemoName);
    if MemoHandle <> 0 then
      pMemoMem := MapViewOfFile(MemoHandle, FILE_MAP_WRITE, 0, 0, 0) else
      pMemoMem := nil;
    MemoMem := pMemoMem;
  end;
  if (StmtHandles[StartExecInfo^.StmtIndex].StmtHandle <> 0) and
    (StmtHandles[StartExecInfo^.StmtIndex].MemoHandle <> 0) then
    with ExecInfo^ do
    begin
      DataSet := GetDataSetByName(S);
      if DataSet <> nil then
      try
        if DataSet.Active then DataSet.First
        else DataSet.Open;
        MoreRecords := not DataSet.EOF;
        NumCols := 0;
        DataElement := PDataElement(pStmtMem);
        Size := 0;
        for I := 0 to DataSet.FieldCount - 1 do
          Inc(Size, GetDataSize(DataSet.Fields[I]) + SizeOf(TDataElement));
        if Size < StatementBuffer then
        begin
          for I := 0 to DataSet.FieldCount - 1 do
            with DataSet.Fields[I], DataElement^ do
              if ValidDataType(DataType) then
              begin
                StrLCopy(ColumnName, PChar(FieldName), SizeOf(ColumnName) - 1);
                FieldType := Ord(DataType);
                FieldLength := GetDataSize(DataSet.Fields[I]);
                Inc(Integer(DataElement), SizeOf(TDataElement) + FieldLength);
                Inc(NumCols);
              end;
          Result := GetData(DataSet, pStmtMem);
        end
        else FLastError := SRptBindBuffer;
      except
        on E: Exception do
          FLastError := E.Message;
      end
      else FLastError := SRptDataSetNotAvailable;
    end
  else FLastError := SRptSharedMemoryError;
end;

function TReportManager.GetData(DataSet: TDataSet; pStmtMem: PDataElement): Bool;
var
  I: Integer;
  DataValue: Pointer;
  DataElement: PDataElement;
begin
  Result := True;
  try
    DataElement := pStmtMem;
    for I := 0 to DataSet.FieldCount - 1 do
      with DataSet.Fields[I], DataElement^ do
        if ValidDataType(DataType) then
        begin
          DataValue := Pointer(@DataElement^.Data);
          Null := IsNull;
          if not Null then
          begin
            case DataType of
              ftString, ftVarBytes:
                StrCopy(PChar(DataValue), PChar(AsString));
              ftBoolean: Bool(DataValue^) := AsBoolean;
              ftSmallint, ftInteger, ftWord, ftAutoInc:
                Integer(DataValue^) := AsInteger;
              ftFloat, ftCurrency, ftBCD:
                Double(DataValue^) := AsFloat;
              ftDate, ftTime, ftDateTime:
                GetDecodedDateTime(AsDateTime, TRSDateTime(DataValue^));
            end;
          end;
          Inc(Integer(DataElement), SizeOf(TDataElement) + FieldLength);
        end;
  except
    on E: Exception do
      begin
        FLastError := E.Message;
        Result := False;
      end;
  end;
end;

function TReportManager.GetNext(SQLStruct: PSQLStruct; var MoreData: Bool): Bool;
var
  pStmtMem: Pointer;
  DataSet: TDataSet;
begin
  Result := False;
  pStmtMem := StmtHandles[SQLStruct^.Index].StmtMem;
  DataSet := SQLStruct^.DataSet;
  if DataSet <> nil then
    try
      DataSet.Next;
      Result := GetData(DataSet, pStmtMem);
      MoreData := not DataSet.EOF;
    except
      on E: Exception do
        FLastError := E.Message;
    end
  else FLastError := SRptNoDataSetAvailable;
end;

function TReportManager.GetMemo(MemoStruct: PMemoStruct): Bool;
var
  MemoMem: Pointer;
  DataSet: TDataSet;
  S: string;
begin
  Result := False;
  MemoMem := StmtHandles[MemoStruct^.Index].MemoMem;
  PChar(MemoMem)^ := #0;
  DataSet := MemoStruct^.DataSet;
  if DataSet <> nil then
    try
      S := DataSet.FieldByName(MemoStruct^.ColumnName).AsString;
      if Length(S) >= MemoStruct^.Pos then
        StrLCopy(MemoMem, @S[MemoStruct^.Pos + 1], MemoBuffer - 1);
      Result := True;
    except
      on E: Exception do
        FLastError := E.Message;
    end
  else FLastError := SRptNoDataSetAvailable;
end;

function TReportManager.ValidDataType(Value: TFieldType): Boolean;
begin
  Result := not (Value in [ftUnknown, ftBytes, ftVarBytes,
    ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary])
end;

function TReportManager.EndSQL(SQLStruct: PSQLStruct): Bool;
begin
  Result := True;
  if SQLStruct^.DataSet <> nil then
  try
    SQLStruct^.DataSet.Close;
    CleanUpStmt(StmtHandles[SQLStruct^.Index]);
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      Result := False;
    end;
  end
end;

function TReportManager.GetDataSets: TList;
begin
  if not Updated then UpdateDataSets;
  Result := FDataSets;
end;

procedure TReportManager.GetTableList(Buffer: PChar);
var
  S: string;
  I: Integer;
begin
  Buffer^ := #0;
  for I := 0 to DataSets.Count - 1 do
  begin
    S := DataSet[I].Name;
    StrCopy(Buffer, PChar(S));
    Inc(Integer(Buffer), Length(S) + 1);
  end;
  Buffer^ := #0;
end;

function TReportManager.GetDataSetByName(Value: string): TDataSet;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to DataSets.Count - 1 do
    if DataSet[I].Name = Value then
    begin
      Result := DataSet[I];
      Break;
    end;
end;

function TReportManager.GetColumnList(Buffer: PChar): Bool;
var
  S: string;
  DataSet: TDataSet;

  procedure GetNamesByField;
  var
    I: Integer;
  begin
    for I := 0 to DataSet.FieldCount - 1 do
      if ValidDataType(DataSet.Fields[I].DataType) then
      begin
        S := DataSet.Fields[I].FieldName;
        StrCopy(Buffer, PChar(S));
        Inc(Integer(Buffer), Length(S) + 1);
      end;
  end;

  procedure GetNamesByFieldDef;
  var
    I: Integer;
  begin
    for I := 0 to DataSet.FieldDefs.Count - 1 do
      if ValidDataType(DataSet.FieldDefs[I].DataType) then
      begin
        S := DataSet.FieldDefs[I].Name;
        StrCopy(Buffer, PChar(S));
        Inc(Integer(Buffer), Length(S) + 1);
      end;
  end;

begin
  Result := True;
  S := Buffer;
  Buffer^ := #0;
  DataSet := GetDataSetByName(S);
  if DataSet <> nil then
    with DataSet do
    try
      FieldDefs.Update;
      if FieldCount <> 0 then
        GetNamesByField else
        GetNamesByFieldDef;
    except
      on E: Exception do
        begin
          FLastError := E.Message;
          Result := False;
        end;
    end
  else begin
    FLastError := SRptNoDataSetAvailable;
    Result := False;
  end;
  Buffer^ := #0;
end;

procedure ProcessRequest;
var
  pData: Pointer;
  CallRec: PCallInfo;
begin
  CallRec := PCallInfo(SharedMem);
  pData := @CallRec^.Data;
  if (CallRec^.CallType = ctDesignId) and
    (ReportManager.Reports.Count > 0) and
    (csDesigning in ReportManager.Report[0].ComponentState) then
  begin
    CallRec^.ErrorCode := False;
    DWORD(pData^) := ProcessId;
  end
  else if CallRec^.ProcessId = ProcessId then
    SendMessage(ReportManager.Handle, $7F00, 0, 0);
  ResetEvent(StartEvent);
  SetEvent(SyncEvent);
end;

function WaitForRequest(pData: Pointer): Integer; stdcall;
begin
  Result := 0;
  while True do
  begin
    Result := WaitForSingleObject(StartEvent, INFINITE);
    if Result = WAIT_OBJECT_0 then ProcessRequest
    else break;
  end;
end;

procedure Initialize;
begin
  ReportManager := TReportManager.Create(nil);
  ProcessId := GetCurrentProcessId;
  if InitDriver then
    InitObjects(StartEvent, SyncEvent, SharedMem, @WaitForRequest);
  if InitAPIDriver then
    RS_RegisterCallBack(@AsyncCallback);
end;

procedure Finalize;
var
  Thread: THandle;
  I: Integer;
begin
  for I := Low(StmtHandles) to High(StmtHandles) do
    CleanUpStmt(StmtHandles[I]);
  if @GetThread <> nil then
  begin
    Thread := GetThread;
    if Thread <> 0 then TerminateThread(Thread, 0);
  end;
  ReportManager.Free;
  if DriverLoaded then FreeLibrary(DriverHandle);
  if APIDriverLoaded then FreeLibrary(APIDriverHandle);
end;

initialization
  Initialize;
finalization
  Finalize;
end.